home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources1 / Runtime (.c & .h) / gc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-09-23  |  20.7 KB  |  354 lines  |  [TEXT/KAHL]
  1. /* Garbage collection */
  2.  
  3. #include "params.h"
  4. #include "gambit.h"
  5. #include "struct.h"
  6. #include "os.h"
  7. #include "opcodes.h"
  8. #include "run.h"
  9.  
  10.  
  11. /*---------------------------------------------------------------------------*/
  12.  
  13.  
  14. void gc_flip();
  15. void gc_scan_range();
  16.  
  17.  
  18. long gc_report; /* index of '##gc-report' variable */
  19.  
  20.  
  21. #ifdef DEBUG_GC
  22. SCM_obj scanned_object;
  23. void show_state();
  24. #endif
  25.  
  26.  
  27. void gc()
  28. { char *nb, *nt;     /* new space bottom and top  */
  29.   SCM_obj *fb, *ft;  /* free space bottom and top */
  30.   long cpu_times1[2], cpu_times2[2];
  31.  
  32.   os_cpu_times( cpu_times1 );
  33.  
  34.   os_notify_gc_begin( SCM_obj_to_int(pstate->id),
  35.                       (long)(sstate->globals[gc_report].value != (long)SCM_false) );
  36.  
  37.   if (pstate->heap_old > pstate->heap_bot)
  38.   { pstate->heap_old = pstate->heap_bot;
  39.     nb = pstate->heap_mid;
  40.     nt = pstate->heap_top;
  41.   }
  42.   else
  43.   { pstate->heap_old = pstate->heap_mid;
  44.     nb = pstate->heap_bot;
  45.     nt = pstate->heap_mid;
  46.   }
  47.  
  48.   gc_flip( (char *)sstate, sstate->const_top, nb, nt, &fb, &ft );
  49.  
  50.   pstate->heap_lim = ((char *)fb) + pstate->heap_margin + (HEAP_ALLOCATION_FUDGE)*sizeof(SCM_obj);
  51.   pstate->heap_ptr = (char *)ft;
  52.  
  53.   pstate->closure_lim = (char *)ft;
  54.   pstate->closure_ptr = (char *)ft;
  55.  
  56.   os_notify_gc_end( SCM_obj_to_int(pstate->id), pstate->heap_mid, pstate->heap_bot, (char *)fb, (char *)ft,
  57.                     (long)(sstate->globals[gc_report].value != (long)SCM_false) );
  58.  
  59.   os_cpu_times( cpu_times2 );
  60.  
  61.   pstate->stats_counters[STAT_GC] += (cpu_times2[0] - cpu_times1[0]) +
  62.                                      (cpu_times2[1] - cpu_times1[1]);
  63. }
  64.  
  65.  
  66. /*---------------------------------------------------------------------------*/
  67.  
  68.  
  69. #define gc_scan_closure(ptr,header) \
  70.   gc_scan_range((SCM_obj *)ptr, SCM_closure_slots(header), (long)sizeof(SCM_obj))
  71.  
  72.  
  73. void gc_scan_roots()
  74. { long i, g, n, m;
  75.   char *ptr, *limit;
  76.  
  77.   /* scan processor local storage (each processor has its own) */
  78.  
  79. #ifdef DEBUG_GC
  80.   scanned_object = 0;
  81.   if (sstate->debug)
  82.   { show_state();
  83.     os_warn( "[%d: SCANNING processor local storage]\n", SCM_obj_to_int(pstate->id) );
  84.   }
  85. #endif
  86.  
  87.   gc_scan_range( (SCM_obj *)pstate->processor_storage,
  88.                  (long)(sizeof(pstate->processor_storage) / sizeof(SCM_obj)),
  89.                  (long)sizeof(SCM_obj) );
  90.  
  91.   /* scan global vars (distribute work among processors) */
  92.  
  93. #ifdef DEBUG_GC
  94.   if (sstate->debug)
  95.   { show_state();
  96.     os_warn( "[%d: SCANNING global variables]\n", SCM_obj_to_int(pstate->id) );
  97.   }
  98. #endif
  99.  
  100.   g = SCM_obj_to_int( sstate->globals[GLOBAL_VAR_COUNT].value );
  101.   n = SCM_obj_to_int(pstate->nb_processors);
  102.   m = g/n;
  103.   if (SCM_obj_to_int(pstate->id) < (g%n)) m++;
  104.   gc_scan_range( (SCM_obj *)&sstate->globals[SCM_obj_to_int(pstate->id)].value, m, n*sizeof(struct global_rec) );
  105.  
  106.   for (i=0; i<m; i++)
  107.     sstate->globals[SCM_obj_to_int(pstate->id)+i*n].jump_adr =
  108.       (long)&sstate->tramps[SCM_obj_to_int(pstate->id)+i*n];
  109.  
  110.   /* scan stack (each processor has an independent stack) */
  111.  
  112. #ifdef DEBUG_GC
  113.   if (sstate->debug)
  114.   { show_state();
  115.     os_warn( "[%d: SCANNING stack]\n", SCM_obj_to_int(pstate->id) );
  116.   }
  117. #endif
  118.  
  119.   gc_scan_range( (SCM_obj *)pstate->stack_ptr,
  120.                  (long)(pstate->ltq_head[-1] - pstate->stack_ptr),
  121.                  (long)sizeof(SCM_obj) );
  122.  
  123.   /* scan work queue (each processor has its own) */
  124.  
  125. #ifdef DEBUG_GC 
  126.   if (sstate->debug)
  127.     os_warn( "[%d: SCANNING work queue]\n", SCM_obj_to_int(pstate->id) );
  128. #endif
  129.  
  130.   gc_scan_range( (SCM_obj *)&pstate->workq_head, 1L, (long)sizeof(SCM_obj) );
  131.   gc_scan_range( (SCM_obj *)&pstate->workq_tail, 1L, (long)sizeof(SCM_obj) );
  132.  
  133.   /* scan current task (each processor has its own) */
  134.  
  135. #ifdef DEBUG_GC
  136.   if (sstate->debug)
  137.   { show_state();
  138.     os_warn( "[%d: SCANNING current task]\n", SCM_obj_to_int(pstate->id) );
  139.   }
  140. #endif
  141.  
  142.   gc_scan_range( (SCM_obj *)&pstate->current_task, 1L, (long)sizeof(SCM_obj) );
  143.   gc_scan_range( (SCM_obj *)&pstate->parent_ret, 1L, (long)sizeof(SCM_obj) );
  144.   gc_scan_range( (SCM_obj *)&pstate->parent_frame, 1L, (long)sizeof(SCM_obj) );
  145.   gc_scan_range( (SCM_obj *)&pstate->current_dyn_env, 1L, (long)sizeof(SCM_obj) );
  146.   gc_scan_range( (SCM_obj *)&pstate->temp_task, 1L, (long)sizeof(SCM_obj) );
  147.   gc_scan_range( (SCM_obj *)&pstate->response, 1L, (long)sizeof(SCM_obj) );
  148.  
  149.   /* scan constant space (each processor GCs its own copy) */
  150.  
  151. #ifdef DEBUG_GC
  152.   if (sstate->debug)
  153.   { show_state();
  154.     os_warn( "[%d: SCANNING constant space (with headers)]\n", SCM_obj_to_int(pstate->id) );
  155.   }
  156. #endif
  157.  
  158.   ptr = sstate->const_bot;
  159.   limit = sstate->const_bptr;
  160.  
  161.   while (ptr < limit)
  162.   { long len, header = om )
  163. SCM_obj value, object, *from;
  164. { os_warn( "\nGC ERROR: object 0x%x ", (long)object );
  165.   os_warn( "at 0x%x ", (long)from );
  166.   os_warn( "contains invalid value 0x%x\n", (long)value );
  167.   show_object( object, 0L );
  168.   os_quit();
  169. }
  170.  
  171. int correct_value( value )
  172. SCM_obj value;
  173. { if ((SCM_type(value)!=SCM_type_FIXNUM)&&(SCM_type(value)!=SCM_type_SPECIAL))
  174.     if ((((long)value) < const_bot) || (((long)value) >= const_top))
  175.     { int i;
  176.       for (i=SCM_obj_to_int(pstate->nb_processors)-1; i>=0; i--)
  177.         if ((value >= (long)pstate->ps[i]->heap_bot) &&
  178.             (value <= (long)pstate->ps[i]->heap_top)) return 1;
  179.       return 0;
  180.     }
  181.   return 1;
  182. }
  183.  
  184. #define CHECK_VALID(value,object,from) { if (!correct_value( value )) show_invalid( value, object, from ); }
  185.  
  186. #else
  187.  
  188. #define CHECK_VALID(value,object,from)
  189.  
  190. #endif
  191.  
  192.  
  193. /*-----------------------------------------------------------------------------
  194.  *
  195.  * Scan a range of memory for garbage-collectable objects.  Referenced
  196.  * objects are copied from OLD space to NEW space.
  197.  *
  198.  */
  199.  
  200.  
  201. #define FORWARD_NO_HEADER FORWARD(SCM_copied_no_header(slot0),adr[1])
  202. #define FORWARD_HEADER    FORWARD(SCM_copied_header(slot0),slot0)
  203. #define FORWARD_CLOSURE   FORWARD(!SCM_header_closure(slot0),slot0)
  204. #define FORWARD(copied,forw_ptr)                                      \
  205. adr = SCM_object_adr(object);          /* Get address of object    */ \
  206. read_and_lock(adr, slot0);             /* Lock it and get slot 0   */ \
  207. if (copied)                            /* Has it been copied?      */ \
  208. { *from = forw_ptr;                    /* Update reference         */ \
  209.   CHECK_VALID( forw_ptr, scanned_object, from );                      \
  210.   unlock(adr, slot0);                  /* and unlock object        */ \
  211. }                                                                     \
  212. else
  213.  
  214.  
  215. void gc_scan_range( from, count, step )
  216. SCM_obj *from;                   /* Where to start scanning                  */
  217. long count;                      /* Number of objects to scan                */
  218. long step;                       /* Step between objects (in bytes)          */
  219. { register SCM_obj object;               /* Object being checked             */
  220.   register SCM_obj object_copy;          /* Object after data copied         */
  221.   register SCM_obj *adr;                 /* Pointer to data if mem alloc obj */
  222.   register long slot0;                   /* First slot of that data          */
  223.   register SCM_obj len;                  /* Length of headed object          */
  224.   register SCM_obj *b_alloc = bot_alloc; /* Local copy of bot_alloc          */
  225.   register SCM_obj *t_alloc = top_alloc; /* Local copy of top_alloc          */
  226.  
  227.   while (count-- > 0)                            /* Scan every object        */
  228.   { object = *from;                              /* Fetch next object        */
  229. Rescan:
  230.     if ((((long)object) <  const_bot) ||         /* Don't process objects    */
  231.         (((long)object) >= const_top))           /* stored in constant space */
  232.     {
  233. #ifdef DEBUG_GC
  234.       if (!correct_value( object ))
  235.       { os_warn( "\nGC ERROR: found invalid value 0x%x ", (long)object );
  236.         os_warn( "at 0x%x while scanning\n", (long)from );
  237.         show_object( 0L, from );
  238.         os_quit();
  239.       }
  240. #endif
  241.       switch SCM_type(object)                    /* Dispatch on type         */
  242.       { case SCM_type_PAIR:
  243.           FORWARD_NO_HEADER
  244.           { CHECK_VALID( adr[1], object, from );
  245.             CHECK_VALID( slot0, object, from );
  246.             *(--t_alloc) = adr[1];               /* Allocate and copy pair   */
  247.             *(--t_alloc) = slot0;
  248.             object_copy = SCM_add_type(t_alloc, SCM_type_PAIR);
  249.             adr[1] = object_copy;                /* Remember where copied    */
  250.             store_and_unlock(adr, (long)SCM_BH); /* Mark as copied & unlock  */
  251.             *from = object_copy;                 /* Update reference         */
  252.             CHECK_VALID( object_copy, scanned_object, from );
  253.           }
  254.           break;
  255.  
  256.         case SCM_type_PROCEDURE:                 /* Must be closure          */
  257.           FORWARD_CLOSURE
  258.           { object_copy = SCM_add_type(b_alloc, SCM_type_PROCEDURE);
  259.             *(b_alloc++) = slot0;
  260.             store_and_unlock(adr, object_copy);  /* remember where copied    */
  261.             len = SCM_procedure_length(slot0);
  262.             adr++;
  263.             while (len>0)
  264.             { CHECK_VALID( *adr, object, from );
  265.               *(b_alloc++) = *(adr++);
  266.               len -= sizeof(SCM_obj);
  267.             }
  268.             b_alloc = (SCM_obj *)SCM_align(b_alloc);
  269.             *from = object_copy;                 /* update reference         */
  270.             CHECK_VALID( object_copy, scanned_object, from );
  271.           }
  272.           break;
  273.  
  274.         case SCM_type_SUBTYPED:
  275.           FORWARD_HEADER
  276.           { object_copy = SCM_add_type(b_alloc, SCM_type_SUBTYPED);
  277.             *(b_alloc++) = slot0;
  278.             store_and_unlock(adr, object_copy);  /* remember where copied    */
  279.             len = SCM_header_length(slot0);
  280.             adr++;
  281. #ifdef DEBUG_GC
  282.             if (SCM_subtype_is_ovector(SCM_header_subtype( slot0 )))
  283.               while (len>0)
  284.               { CHECK_VALID( *adr, object, from );
  285.                 *(b_alloc++) = *(adr++);
  286.                 len -= sizeof(SCM_obj);
  287.               }
  288.             else
  289. #endif
  290.               while (len>0)
  291.               { *(b_alloc++) = *(adr++); len -= sizeof(SCM_obj); }
  292.             b_alloc = (SCM_obj *)SCM_align(b_alloc);
  293.             *from = object_copy;                 /* update reference         */
  294.             CHECK_VALID( object_copy, scanned_object, from );
  295.           }
  296.           break;
  297.  
  298.         case SCM_type_PLACEHOLDER:
  299.           /* Assumption: slot 0 is the value slot, and is itself
  300.              if not yet determined */
  301.           FORWARD_NO_HEADER
  302.           { if (slot0 != object)                 /* Determined?              */
  303.             { unlock(adr, slot0);                /* Unlock & restore value   */
  304.               object = slot0;                    /* Rescan value             */
  305.               *from = object;                    /* Replace P.H. by value    */
  306.               CHECK_VALID( object, scanned_object, from );
  307.               goto Rescan;
  308.             }
  309.             CHECK_VALID( adr[3], object, from );
  310.             CHECK_VALID( adr[2], object, from );
  311.             CHECK_VALID( adr[1], object, from );
  312.             CHECK_VALID( slot0, object, from );
  313.             *(--t_alloc) = adr[3];
  314.             *(--t_alloc) = adr[2];
  315.             *(--t_alloc) = adr[1];
  316.             *(--t_alloc) = slot0;
  317.             object_copy = SCM_add_type(t_alloc, SCM_type_PLACEHOLDER);
  318.             adr[1] = object_copy;                /* Remember where copied    */
  319.             store_and_unlock(adr, (long)SCM_BH); /* Mark as copied & unlock  */
  320.             *from = object_copy;                 /* Update reference         */
  321.             CHECK_VALID( object_copy, scanned_object, from );
  322.           }
  323.           break;
  324.  
  325.         case SCM_type_WEAK_PAIR:
  326.           FORWARD_NO_HEADER
  327.           { CHECK_VALID( adr[1], object, from );
  328.             CHECK_VALID( slot0, object, from );
  329.             *(b_alloc++) = SCM_make_header(3*sizeof(SCM_obj),SCM_subtype_WEAK_PAIR);
  330.             *(b_alloc++) = (SCM_obj)weak_pairs;
  331.             weak_pairs = b_alloc;
  332.             object_copy = SCM_add_type(b_alloc, SCM_type_WEAK_PAIR);
  333.             *(b_alloc++) = slot0;                /* Allocate and copy pair   */
  334.             *(b_alloc++) = adr[1];
  335.             adr[1] = object_copy;                /* Remember where copied    */
  336.             store_and_unlock(adr, (long)SCM_BH); /* Mark as copied & unlock  */
  337.             *from = object_copy;                 /* Update reference         */
  338.             CHECK_VALID( object_copy, scanned_object, from );
  339.           }
  340.           break;
  341.  
  342.         case SCM_type_FIXNUM:
  343.         case SCM_type_SPECIAL: break;
  344.  
  345.         default:
  346.           os_warn( "\nGC ERROR: Bad type code, object=0x%x", (long)object );
  347. #ifdef DEBUG_GC
  348.           if (scanned_object != 0) os_warn( " in 0x%x", scanned_object );
  349. #endif
  350.           os_warn( " at 0x%x\n", (long)from );
  351. #ifdef DEBUG_GC
  352.           show_object( scanned_object, from );
  353. #endif
  354.